home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / strings.swg / 0134_SoundEx String Routine.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-08-30  |  8.9 KB  |  365 lines
  1. uses crt,dos;
  2. var infile:text;
  3.     instring,st1,st2,st3:string;
  4.     letter:string[1];
  5.     j:integer;
  6.     h,m,s,hund,h2,m2,s2,hund2:Word;
  7.     avail,avail2:longint;
  8.  
  9. FUNCTION SOUNDEXxx(na:string):string;
  10. {fine, not too fast, converted from BASIC routine, has gotos}
  11. var i,e,valcode,value:integer;
  12.     k,ee,l,cd:string;
  13. const
  14.     code:string='01230120022455012623010202';
  15.                { ABCDEFGHIJKLMNOPQRSTUVWXYZ }
  16. label 312,314;
  17.  
  18. begin
  19.    l:='';
  20.    k:='';
  21.    cd:='';
  22.    if length(na)<2 then goto 314;
  23.    for i:= 2 to length(na) do
  24.    begin
  25.       na[i]:=upcase(na[i]);
  26.       if na[i] in ['A' .. 'Z'] then e:=ord(na[i])-64 else e:=0;
  27.       if (e>26) or (e<1) then goto 312;
  28.       k:=copy(code,e,1);
  29.       if (k=l) or (k='0') then goto 312;
  30.       cd:=concat(cd,k);
  31.       if length(cd) >2 then goto 314;
  32. 312:  l:=k;
  33.    end;
  34. 314:  cd:=concat(cd,'0000');
  35.       delete(cd,4,30);
  36.       soundexxx:=cd;
  37. end; { SOUNDEXxx }
  38.  
  39.  
  40.  
  41. FUNCTION SOUNDEX3(na:string):string;
  42. {same as soundexxx without gotos, faster}
  43. var i,e,ll:integer;
  44.     l,cd,k:string;
  45.  
  46. const
  47.     code : string = '01230120022455012623010202';
  48.     letters:string= 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  49. begin
  50.      l:='';
  51.      k:='';
  52.      cd:='';
  53.      if length(na)<2 then
  54.      begin
  55.         soundex3:='000';
  56.         exit;
  57.      end;
  58.      i:=2;
  59.      ll:=length(na);
  60.      repeat
  61.         na[i]:=upcase(na[i]);
  62.         if na[i] in ['A'..'Z'] then e:=ord(na[i])-64 else e:=0;
  63.         if e>0 then
  64.         begin
  65.            k:=copy(code,e,1);
  66.            if (k<>l)and(k<>'0') then
  67.            begin
  68.               cd:=cd+k;
  69.               if length(cd)>2 then i:=ll+1;
  70.            end;
  71.         end;
  72.         l:=k;
  73.         inc(i);
  74.      until i>ll;
  75.      cd:=cd+'000';
  76.      soundex3:=copy(cd,1,3);
  77. end; { SOUNDEX3 }
  78.  
  79.  
  80.  
  81. FUNCTION SOUNDEX3b(na:string):string;
  82. {same as soundexxx without gotos, fastest}
  83. var i,p,ll:integer;
  84.     l,k,j:char;
  85.     cd:string[3];
  86. const code:string='901230120022455012623010202';
  87.     letters:string='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  88.  
  89. begin
  90.    l:=#0;
  91.    k:=#0;
  92.    j:=#0;
  93.    p:=1;
  94.    cd:='000';
  95.    if length(na)<2 then
  96.    begin
  97.       soundex3b:=cd;
  98.       exit;
  99.    end;
  100.    i:=2;
  101.    ll:=length(na);
  102.    repeat
  103.       j:=code[succ(pos(upcase(na[i]),letters))];
  104.       if (j<>'9')then k:=j;
  105.       if (k<>l)and(k<>'0') then
  106.       begin
  107.          cd[p]:=k;
  108.          inc(p);
  109.          if p>3 then i:=ll+1;
  110.       end;
  111.       l:=k;
  112.       inc(i);
  113.    until i>ll;
  114.    soundex3b:=cd;
  115. end; { SOUNDEX3b }
  116.  
  117.  
  118. function soundex_asm(var S:string):string;assembler;
  119. const trans:array[0..25]of byte=
  120.   (0,1,2,3,0,1,2,0,0,2,2,4,5,5,0,1,2,6,2,3,0,1,0,2,0,2);
  121.  { a b c d e f g h i j k l m n o p q r s t u v w x y z }
  122. asm
  123.    cld              {set direction}
  124.    les di,@result   {pointer to output soundex code}
  125.    Xor ax,ax
  126.    mov bx,di
  127.    add bx,3         {bx=pointer last char of soundex}
  128.    mov al,3
  129.    stosb            {length of result}
  130.    mov al,'0'
  131.    push di
  132.    mov cx,3
  133.    repnz stosb      {pad soundex with '000'}
  134.    pop di           {points to first byte of soundex code}
  135.    lds si,[S]       {pointer to input string}
  136.    Xor ax,ax
  137.    mov al,[si]      {length of input string}
  138.    cmp al,1         {input must be at least 2 characters long}
  139.    jbe @quitter     {too short, or null input string - bail}
  140.    add ax,si
  141.    mov dx,ax        {dx=pointer last byte S}
  142.    inc si
  143.    inc si           {si=pointer second byte S}
  144.                     {dx=lastchar s}
  145.                     {bx=lastchar result}
  146.                     {si=secondchar s}
  147.                     {di=firstchar result}
  148.                     {cx=last letter code rememberers}
  149.    mov cx,0
  150.  @nextchar:
  151.    xor ax,ax
  152.    lodsb            {get next char from input}
  153.    cmp al,'Z'       {check for upper case}
  154.    jg  @CaseOK
  155.    cmp al,'A'
  156.    jl  @CaseOK
  157.    or al,$20        {make lower case}
  158. @CaseOK:
  159.    cmp al,'z'       {check for alphabetical range}
  160.    jg @nocode
  161.    cmp al,'a'
  162.    jl @nocode
  163.    sub al,'a'       {shift down so 'a'=0 for translation offset}
  164.    push bx          {save pointer}
  165.    mov bx,offset trans
  166.    xlat             {get translation value}
  167.    pop bx           {retreive end of input string pointer}
  168.    mov ch,al
  169.    cmp al,0
  170.    je @nocode
  171.    cmp ch,cl
  172.    je @nocode
  173.    add al,'0'
  174.    stosb          {put soundex in code}
  175. @nocode:
  176.    mov cl,ch
  177.    cmp di,bx
  178.    jg @quitter
  179.    cmp si,dx
  180.    jbe @nextchar
  181.  @quitter:
  182. end;
  183.  
  184.  
  185.  
  186. function soundex_asm2(var S:string):string;assembler;
  187. {works without global variable}
  188. asm
  189.    jmp @start
  190. @trans: DB 0,1,2,3,0,1,2,0,0,2,2,4,5,5,0,1,2,6,2,3,0,1,0,2,0,2
  191.          { a b c d e f g h i j k l m n o p q r s t u v w x y z }
  192. @start:
  193.    push ds
  194.    cld              {set direction}
  195.    les di,@result   {pointer to output soundex code}
  196.    Xor ax,ax
  197.    mov bx,di
  198.    add bx,3         {bx=pointer last char of soundex}
  199.    mov al,3
  200.    stosb            {length of result}
  201.    mov al,'0'
  202.    push di
  203.    mov cx,3
  204.    repnz stosb      {pad soundex with '000'}
  205.    pop di           {points to first byte of soundex code}
  206.    lds si,S       {pointer to input string}
  207.    Xor ax,ax
  208.    lodsb
  209.   { mov al,[si]}      {length of input string}
  210.    cmp al,1         {input must be at least 2 characters long}
  211.    jbe @quitter     {too short, or null input string - bail}
  212.    add ax,si
  213.    mov dx,ax        {dx=pointer last byte S}
  214.    dec dx
  215. {   inc si}
  216.    inc si           {si=pointer second byte S}
  217.                     {dx=lastchar s}
  218.                     {bx=lastchar result}
  219.                     {si=secondchar s}
  220.                     {di=firstchar result}
  221.                     {cx=last letter code rememberers}
  222.    mov cx,0
  223.  @nextchar:
  224.    xor ax,ax
  225.    lodsb            {get next char from input}
  226.    cmp al,'Z'       {check for upper case}
  227.    jg  @CaseOK
  228.    cmp al,'A'
  229.    jl  @CaseOK
  230.    or al,$20        {make lower case}
  231. @CaseOK:
  232.    cmp al,'z'       {check for alphabetical range}
  233.    jg @nocode
  234.    cmp al,'a'
  235.    jl @nocode
  236.    sub al,'a'       {shift down so 'a'=0 for translation offset}
  237.    push bx          {save pointer}
  238.    mov bx,offset @trans
  239.    SEGCS xlat             {get translation value}
  240.    pop bx           {retreive end of input string pointer}
  241.    mov ch,al
  242.    cmp al,0
  243.    je @nocode
  244.    cmp ch,cl
  245.    je @nocode
  246.    add al,'0'
  247.    stosb          {put soundex in code}
  248. @nocode:
  249.    mov cl,ch
  250.    cmp di,bx
  251.    jg @quitter
  252.    cmp si,dx
  253.    jbe @nextchar
  254.  @quitter:
  255.    pop ds
  256. end;
  257.  
  258.  
  259.  
  260. function experiment(var s:string):string;
  261. begin
  262.    experiment:=soundex_asm2(s);
  263. end;
  264.  
  265.  
  266. procedure compare;
  267. var istr:string;
  268. begin
  269.    write(letter,',');
  270.    while not eof(infile) do
  271.    begin
  272.       readln(infile,instring);
  273.       if letter[1]<>upcase(instring[1]) then
  274.       begin
  275.          letter[1]:=upcase(instring[1]);
  276.          write(letter,',');
  277.       end;
  278.       istr:=instring;
  279.       st2:=soundexxx(instring);
  280.       if soundex3(instring)<>st2 then write('sx3 ');
  281.       if soundex3b(instring)<>st2 then write('sx3b ');
  282. {      if soundex_asm2(instring)<>st2 then write('sxasm ');}
  283.       if experiment(instring)<>st2 then write('sxasm');
  284.       st1:=soundex3b(instring);
  285.       if(st1<>st2) then
  286.          writeln(instring,' ',st1,' ',st2);
  287.       if istr<>instring then writeln(istr,'  ',instring);
  288.    end;
  289.    writeln;
  290. end;
  291.  
  292. procedure speed;
  293. var t1,t2:real;
  294. begin
  295.    writeln('timing soundexxx');
  296.    close(infile);
  297.    reset(infile);
  298.    GetTime(h,m,s,hund);
  299.    while not eof(infile)do
  300.    begin
  301.       readln(infile,instring);
  302.       st1:=soundexxx(instring);
  303.    end;
  304.    gettime(h2,m2,s2,hund2);
  305.    t1:=(h*3600)+(m*60)+s+(hund/100);
  306.    t2:=(h2*3600)+(m2*60)+s2+(hund2/100);
  307.    WriteLn('Elapsed time ',(t2-t1):0:2,' seconds');
  308.    writeln;
  309.    writeln('timing soundex3');
  310.    close(infile);
  311.    reset(infile);
  312.    GetTime(h,m,s,hund);
  313.    while not eof(infile)do
  314.    begin
  315.       readln(infile,instring);
  316.       st1:=soundex3(instring);
  317.    end;
  318.    gettime(h2,m2,s2,hund2);
  319.    t1:=(h*3600)+(m*60)+s+(hund/100);
  320.    t2:=(h2*3600)+(m2*60)+s2+(hund2/100);
  321.    WriteLn('Elapsed time ',(t2-t1):0:2,' seconds');
  322.    writeln;
  323.  
  324.    writeln('timing soundex3b');
  325.    close(infile);
  326.    reset(infile);
  327.    GetTime(h,m,s,hund);
  328.    while not eof(infile)do
  329.    begin
  330.       readln(infile,instring);
  331.       st1:=soundex3b(instring);
  332.    end;
  333.    gettime(h2,m2,s2,hund2);
  334.    t1:=(h*3600)+(m*60)+s+(hund/100);
  335.    t2:=(h2*3600)+(m2*60)+s2+(hund2/100);
  336.    WriteLn('Elapsed time ',(t2-t1):0:2,' seconds');
  337.    writeln;
  338.    writeln('timing soundex_asm');
  339.    close(infile);
  340.    reset(infile);
  341.    GetTime(h,m,s,hund);
  342.    while not eof(infile)do
  343.    begin
  344.       readln(infile,instring);
  345.       st1:=soundex_asm(instring);
  346.    end;
  347.    gettime(h2,m2,s2,hund2);
  348.    t1:=(h*3600)+(m*60)+s+(hund/100);
  349.    t2:=(h2*3600)+(m2*60)+s2+(hund2/100);
  350.    WriteLn('Elapsed time ',(t2-t1):0:2,' seconds');
  351. end;
  352.  
  353.  
  354.  
  355. begin
  356.    clrscr;
  357.    letter:='A';
  358.    assign(infile,'d:\spell\tmp\wookdic.asc');
  359.    reset(infile);
  360.    instring:='accord';
  361.    st1:=soundex_asm(instring);
  362.    compare;
  363. {   speed;}
  364.    close(infile);
  365. end.